home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / Xlisp_Source.cpt / xlcont.c < prev    next >
Text File  |  1985-04-08  |  17KB  |  803 lines
  1. /* xlcont - xlisp control built-in functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. #ifdef MEGAMAX
  6. overlay "overflow"
  7. #endif
  8.  
  9. /* external variables */
  10. extern NODE *xlstack,*xlenv,*xlnewenv,*xlvalue;
  11. extern NODE *s_unbound;
  12. extern NODE *s_evalhook,*s_applyhook;
  13. extern NODE *true;
  14.  
  15. /* external routines */
  16. extern NODE *xlxeval();
  17.  
  18. /* forward declarations */
  19. FORWARD NODE *let();
  20. FORWARD NODE *prog();
  21. FORWARD NODE *progx();
  22. FORWARD NODE *doloop();
  23.  
  24. /* xcond - built-in function 'cond' */
  25. NODE *xcond(args)
  26.   NODE *args;
  27. {
  28.     NODE *oldstk,arg,list,*val;
  29.  
  30.     /* create a new stack frame */
  31.     oldstk = xlsave(&arg,&list,NULL);
  32.  
  33.     /* initialize */
  34.     arg.n_ptr = args;
  35.  
  36.     /* initialize the return value */
  37.     val = NIL;
  38.  
  39.     /* find a predicate that is true */
  40.     while (arg.n_ptr) {
  41.  
  42.     /* get the next conditional */
  43.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  44.  
  45.     /* evaluate the predicate part */
  46.     if (xlevarg(&list.n_ptr)) {
  47.  
  48.         /* evaluate each expression */
  49.         while (list.n_ptr)
  50.         val = xlevarg(&list.n_ptr);
  51.  
  52.         /* exit the loop */
  53.         break;
  54.     }
  55.     }
  56.  
  57.     /* restore the previous stack frame */
  58.     xlstack = oldstk;
  59.  
  60.     /* return the value */
  61.     return (val);
  62. }
  63.  
  64. /* xand - built-in function 'and' */
  65. NODE *xand(args)
  66.   NODE *args;
  67. {
  68.     NODE *oldstk,arg,*val;
  69.  
  70.     /* create a new stack frame */
  71.     oldstk = xlsave(&arg,NULL);
  72.  
  73.     /* initialize */
  74.     arg.n_ptr = args;
  75.     val = true;
  76.  
  77.     /* evaluate each argument */
  78.     while (arg.n_ptr)
  79.  
  80.     /* get the next argument */
  81.     if ((val = xlevarg(&arg.n_ptr)) == NIL)
  82.         break;
  83.  
  84.     /* restore the previous stack frame */
  85.     xlstack = oldstk;
  86.  
  87.     /* return the result value */
  88.     return (val);
  89. }
  90.  
  91. /* xor - built-in function 'or' */
  92. NODE *xor(args)
  93.   NODE *args;
  94. {
  95.     NODE *oldstk,arg,*val;
  96.  
  97.     /* create a new stack frame */
  98.     oldstk = xlsave(&arg,NULL);
  99.  
  100.     /* initialize */
  101.     arg.n_ptr = args;
  102.     val = NIL;
  103.  
  104.     /* evaluate each argument */
  105.     while (arg.n_ptr)
  106.     if ((val = xlevarg(&arg.n_ptr)))
  107.         break;
  108.  
  109.     /* restore the previous stack frame */
  110.     xlstack = oldstk;
  111.  
  112.     /* return the result value */
  113.     return (val);
  114. }
  115.  
  116. /* xif - built-in function 'if' */
  117. NODE *xif(args)
  118.   NODE *args;
  119. {
  120.     NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
  121.  
  122.     /* create a new stack frame */
  123.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
  124.  
  125.     /* get the test expression, then clause and else clause */
  126.     testexpr.n_ptr = xlarg(&args);
  127.     thenexpr.n_ptr = xlarg(&args);
  128.     elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
  129.     xllastarg(args);
  130.  
  131.     /* evaluate the appropriate clause */
  132.     val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
  133.  
  134.     /* restore the previous stack frame */
  135.     xlstack = oldstk;
  136.  
  137.     /* return the last value */
  138.     return (val);
  139. }
  140.  
  141. /* xlet - built-in function 'let' */
  142. NODE *xlet(args)
  143.   NODE *args;
  144. {
  145.     return (let(args,TRUE));
  146. }
  147.  
  148. /* xletstar - built-in function 'let*' */
  149. NODE *xletstar(args)
  150.   NODE *args;
  151. {
  152.     return (let(args,FALSE));
  153. }
  154.  
  155. /* let - common let routine */
  156. LOCAL NODE *let(args,pflag)
  157.   NODE *args; int pflag;
  158. {
  159.     NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
  160.  
  161.     /* create a new stack frame */
  162.     oldstk = xlsave(&arg,NULL);
  163.  
  164.     /* initialize */
  165.     arg.n_ptr = args;
  166.  
  167.     /* get the list of bindings and bind the symbols */
  168.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  169.     dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
  170.  
  171.     /* execute the code */
  172.     for (val = NIL; arg.n_ptr; )
  173.     val = xlevarg(&arg.n_ptr);
  174.  
  175.     /* unbind the arguments */
  176.     xlunbind(oldenv); xlnewenv = oldnewenv;
  177.  
  178.     /* restore the previous stack frame */
  179.     xlstack = oldstk;
  180.  
  181.     /* return the result */
  182.     return (val);
  183. }
  184.  
  185. /* xprog - built-in function 'prog' */
  186. NODE *xprog(args)
  187.   NODE *args;
  188. {
  189.     return (prog(args,TRUE));
  190. }
  191.  
  192. /* xprogstar - built-in function 'prog*' */
  193. NODE *xprogstar(args)
  194.   NODE *args;
  195. {
  196.     return (prog(args,FALSE));
  197. }
  198.  
  199. /* prog - common prog routine */
  200. LOCAL NODE *prog(args,pflag)
  201.   NODE *args; int pflag;
  202. {
  203.     NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
  204.  
  205.     /* create a new stack frame */
  206.     oldstk = xlsave(&arg,NULL);
  207.  
  208.     /* initialize */
  209.     arg.n_ptr = args;
  210.  
  211.     /* get the list of bindings and bind the symbols */
  212.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  213.     dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
  214.  
  215.     /* execute the code */
  216.     tagblock(arg.n_ptr,&val);
  217.  
  218.     /* unbind the arguments */
  219.     xlunbind(oldenv); xlnewenv = oldnewenv;
  220.  
  221.     /* restore the previous stack frame */
  222.     xlstack = oldstk;
  223.  
  224.     /* return the result */
  225.     return (val);
  226. }
  227.  
  228. /* xgo - built-in function 'go' */
  229. NODE *xgo(args)
  230.   NODE *args;
  231. {
  232.     NODE *label;
  233.  
  234.     /* get the target label */
  235.     label = xlarg(&args);
  236.     xllastarg(args);
  237.  
  238.     /* transfer to the label */
  239.     xlgo(label);
  240. }
  241.  
  242. /* xreturn - built-in function 'return' */
  243. NODE *xreturn(args)
  244.   NODE *args;
  245. {
  246.     NODE *val;
  247.  
  248.     /* get the return value */
  249.     val = (args ? xlarg(&args) : NIL);
  250.     xllastarg(args);
  251.  
  252.     /* return from the inner most block */
  253.     xlreturn(val);
  254. }
  255.  
  256. /* xprog1 - built-in function 'prog1' */
  257. NODE *xprog1(args)
  258.   NODE *args;
  259. {
  260.     return (progx(args,1));
  261. }
  262.  
  263. /* xprog2 - built-in function 'prog2' */
  264. NODE *xprog2(args)
  265.   NODE *args;
  266. {
  267.     return (progx(args,2));
  268. }
  269.  
  270. /* progx - common progx code */
  271. LOCAL NODE *progx(args,n)
  272.   NODE *args; int n;
  273. {
  274.     NODE *oldstk,arg,val;
  275.  
  276.     /* create a new stack frame */
  277.     oldstk = xlsave(&arg,&val,NULL);
  278.  
  279.     /* initialize */
  280.     arg.n_ptr = args;
  281.  
  282.     /* evaluate the first n expressions */
  283.     while (n--)
  284.     val.n_ptr = xlevarg(&arg.n_ptr);
  285.  
  286.     /* evaluate each remaining argument */
  287.     while (arg.n_ptr)
  288.     xlevarg(&arg.n_ptr);
  289.  
  290.     /* restore the previous stack frame */
  291.     xlstack = oldstk;
  292.  
  293.     /* return the last test expression value */
  294.     return (val.n_ptr);
  295. }
  296.  
  297. /* xprogn - built-in function 'progn' */
  298. NODE *xprogn(args)
  299.   NODE *args;
  300. {
  301.     NODE *oldstk,arg,*val;
  302.  
  303.     /* create a new stack frame */
  304.     oldstk = xlsave(&arg,NULL);
  305.  
  306.     /* initialize */
  307.     arg.n_ptr = args;
  308.  
  309.     /* evaluate each remaining argument */
  310.     for (val = NIL; arg.n_ptr; )
  311.     val = xlevarg(&arg.n_ptr);
  312.  
  313.     /* restore the previous stack frame */
  314.     xlstack = oldstk;
  315.  
  316.     /* return the last test expression value */
  317.     return (val);
  318. }
  319.  
  320. /* xdo - built-in function 'do' */
  321. NODE *xdo(args)
  322.   NODE *args;
  323. {
  324.     return (doloop(args,TRUE));
  325. }
  326.  
  327. /* xdostar - built-in function 'do*' */
  328. NODE *xdostar(args)
  329.   NODE *args;
  330. {
  331.     return (doloop(args,FALSE));
  332. }
  333.  
  334. /* doloop - common do routine */
  335. LOCAL NODE *doloop(args,pflag)
  336.   NODE *args; int pflag;
  337. {
  338.     NODE *oldstk,*oldenv,*oldnewenv,arg,blist,clist,test,*rval;
  339.     int rbreak;
  340.  
  341.     /* create a new stack frame */
  342.     oldstk = xlsave(&arg,&blist,&clist,&test,NULL);
  343.  
  344.     /* initialize */
  345.     arg.n_ptr = args;
  346.  
  347.     /* get the list of bindings and bind the symbols */
  348.     blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  349.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  350.     dobindings(blist.n_ptr,pflag);
  351.  
  352.     /* get the exit test and result forms */
  353.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  354.     test.n_ptr = xlarg(&clist.n_ptr);
  355.  
  356.     /* execute the loop as long as the test is false */
  357.     rbreak = FALSE;
  358.     while (xleval(test.n_ptr) == NIL) {
  359.  
  360.     /* execute the body of the loop */
  361.     if (tagblock(arg.n_ptr,&rval)) {
  362.         rbreak = TRUE;
  363.         break;
  364.     }
  365.  
  366.     /* update the looping variables */
  367.     doupdates(blist.n_ptr,pflag);
  368.     }
  369.  
  370.     /* evaluate the result expression */
  371.     if (!rbreak)
  372.     for (rval = NIL; consp(clist.n_ptr); )
  373.         rval = xlevarg(&clist.n_ptr);
  374.  
  375.     /* unbind the arguments */
  376.     xlunbind(oldenv); xlnewenv = oldnewenv;
  377.  
  378.     /* restore the previous stack frame */
  379.     xlstack = oldstk;
  380.  
  381.     /* return the result */
  382.     return (rval);
  383. }
  384.  
  385. /* xdolist - built-in function 'dolist' */
  386. NODE *xdolist(args)
  387.   NODE *args;
  388. {
  389.     NODE *oldstk,*oldenv,arg,clist,sym,list,val,*rval;
  390.     int rbreak;
  391.  
  392.     /* create a new stack frame */
  393.     oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
  394.  
  395.     /* initialize */
  396.     arg.n_ptr = args;
  397.  
  398.     /* get the control list (sym list result-expr) */
  399.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  400.     sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
  401.     list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
  402.     val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
  403.  
  404.     /* initialize the local environment */
  405.     oldenv = xlenv;
  406.     xlsbind(sym.n_ptr,NIL);
  407.  
  408.     /* loop through the list */
  409.     rbreak = FALSE;
  410.     for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  411.  
  412.     /* bind the symbol to the next list element */
  413.     sym.n_ptr->n_symvalue = car(list.n_ptr);
  414.  
  415.     /* execute the loop body */
  416.     if (tagblock(arg.n_ptr,&rval)) {
  417.         rbreak = TRUE;
  418.         break;
  419.     }
  420.     }
  421.  
  422.     /* evaluate the result expression */
  423.     if (!rbreak) {
  424.     sym.n_ptr->n_symvalue = NIL;
  425.     rval = xleval(val.n_ptr);
  426.     }
  427.  
  428.     /* unbind the arguments */
  429.     xlunbind(oldenv);
  430.  
  431.     /* restore the previous stack frame */
  432.     xlstack = oldstk;
  433.  
  434.     /* return the result */
  435.     return (rval);
  436. }
  437.  
  438. /* xdotimes - built-in function 'dotimes' */
  439. NODE *xdotimes(args)
  440.   NODE *args;
  441. {
  442.     NODE *oldstk,*oldenv,arg,clist,sym,val,*rval;
  443.     int rbreak,cnt,i;
  444.  
  445.     /* create a new stack frame */
  446.     oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
  447.  
  448.     /* initialize */
  449.     arg.n_ptr = args;
  450.  
  451.     /* get the control list (sym list result-expr) */
  452.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  453.     sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
  454.     cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
  455.     val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
  456.  
  457.     /* initialize the local environment */
  458.     oldenv = xlenv;
  459.     xlsbind(sym.n_ptr,NIL);
  460.  
  461.     /* loop through for each value from zero to cnt-1 */
  462.     rbreak = FALSE;
  463.     for (i = 0; i < cnt; i++) {
  464.  
  465.     /* bind the symbol to the next list element */
  466.     sym.n_ptr->n_symvalue = newnode(INT);
  467.     sym.n_ptr->n_symvalue->n_int = i;
  468.  
  469.     /* execute the loop body */
  470.     if (tagblock(arg.n_ptr,&rval)) {
  471.         rbreak = TRUE;
  472.         break;
  473.     }
  474.     }
  475.  
  476.     /* evaluate the result expression */
  477.     if (!rbreak) {
  478.     sym.n_ptr->n_symvalue = newnode(INT);
  479.     sym.n_ptr->n_symvalue->n_int = cnt;
  480.     rval = xleval(val.n_ptr);
  481.     }
  482.  
  483.     /* unbind the arguments */
  484.     xlunbind(oldenv);
  485.  
  486.     /* restore the previous stack frame */
  487.     xlstack = oldstk;
  488.  
  489.     /* return the result */
  490.     return (rval);
  491. }
  492.  
  493. /* xcatch - built-in function 'catch' */
  494. NODE *xcatch(args)
  495.   NODE *args;
  496. {
  497.     NODE *oldstk,tag,arg,*val;
  498.     CONTEXT cntxt;
  499.  
  500.     /* create a new stack frame */
  501.     oldstk = xlsave(&tag,&arg,NULL);
  502.  
  503.     /* initialize */
  504.     tag.n_ptr = xlevarg(&args);
  505.     arg.n_ptr = args;
  506.     val = NIL;
  507.  
  508.     /* establish an execution context */
  509.     xlbegin(&cntxt,CF_THROW,tag.n_ptr);
  510.  
  511.     /* check for 'throw' */
  512.     if (setjmp(cntxt.c_jmpbuf))
  513.     val = xlvalue;
  514.  
  515.     /* otherwise, evaluate the remainder of the arguments */
  516.     else {
  517.     while (arg.n_ptr)
  518.         val = xlevarg(&arg.n_ptr);
  519.     }
  520.     xlend(&cntxt);
  521.  
  522.     /* restore the previous stack frame */
  523.     xlstack = oldstk;
  524.  
  525.     /* return the result */
  526.     return (val);
  527. }
  528.  
  529. /* xthrow - built-in function 'throw' */
  530. NODE *xthrow(args)
  531.   NODE *args;
  532. {
  533.     NODE *tag,*val;
  534.  
  535.     /* get the tag and value */
  536.     tag = xlarg(&args);
  537.     val = (args ? xlarg(&args) : NIL);
  538.     xllastarg(args);
  539.  
  540.     /* throw the tag */
  541.     xlthrow(tag,val);
  542. }
  543.  
  544. /* xerror - built-in function 'error' */
  545. NODE *xerror(args)
  546.   NODE *args;
  547. {
  548.     char *emsg; NODE *arg;
  549.  
  550.     /* get the error message and the argument */
  551.     emsg = xlmatch(STR,&args)->n_str;
  552.     arg = (args ? xlarg(&args) : s_unbound);
  553.     xllastarg(args);
  554.  
  555.     /* signal the error */
  556.     xlerror(emsg,arg);
  557. }
  558.  
  559. /* xcerror - built-in function 'cerror' */
  560. NODE *xcerror(args)
  561.   NODE *args;
  562. {
  563.     char *cmsg,*emsg; NODE *arg;
  564.  
  565.     /* get the correction message, the error message, and the argument */
  566.     cmsg = xlmatch(STR,&args)->n_str;
  567.     emsg = xlmatch(STR,&args)->n_str;
  568.     arg = (args ? xlarg(&args) : s_unbound);
  569.     xllastarg(args);
  570.  
  571.     /* signal the error */
  572.     xlcerror(cmsg,emsg,arg);
  573.  
  574.     /* return nil */
  575.     return (NIL);
  576. }
  577.  
  578. /* xbreak - built-in function 'break' */
  579. NODE *xbreak(args)
  580.   NODE *args;
  581. {
  582.     char *emsg; NODE *arg;
  583.  
  584.     /* get the error message */
  585.     emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
  586.     arg = (args ? xlarg(&args) : s_unbound);
  587.     xllastarg(args);
  588.  
  589.     /* enter the break loop */
  590.     xlbreak(emsg,arg);
  591.  
  592.     /* return nil */
  593.     return (NIL);
  594. }
  595.  
  596. /* xerrset - built-in function 'errset' */
  597. NODE *xerrset(args)
  598.   NODE *args;
  599. {
  600.     NODE *oldstk,expr,flag,*val;
  601.     CONTEXT cntxt;
  602.  
  603.     /* create a new stack frame */
  604.     oldstk = xlsave(&expr,&flag,NULL);
  605.  
  606.     /* get the expression and the print flag */
  607.     expr.n_ptr = xlarg(&args);
  608.     flag.n_ptr = (args ? xlarg(&args) : true);
  609.     xllastarg(args);
  610.  
  611.     /* establish an execution context */
  612.     xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
  613.  
  614.     /* check for error */
  615.     if (setjmp(cntxt.c_jmpbuf))
  616.     val = NIL;
  617.  
  618.     /* otherwise, evaluate the expression */
  619.     else {
  620.     expr.n_ptr = xleval(expr.n_ptr);
  621.     val = newnode(LIST);
  622.     rplaca(val,expr.n_ptr);
  623.     }
  624.     xlend(&cntxt);
  625.  
  626.     /* restore the previous stack frame */
  627.     xlstack = oldstk;
  628.  
  629.     /* return the result */
  630.     return (val);
  631. }
  632.  
  633. /* xevalhook - eval hook function */
  634. NODE *xevalhook(args)
  635.   NODE *args;
  636. {
  637.     NODE *oldstk,*oldenv,expr,ehook,ahook,*val;
  638.  
  639.     /* create a new stack frame */
  640.     oldstk = xlsave(&expr,&ehook,&ahook,NULL);
  641.  
  642.     /* get the expression and the hook functions */
  643.     expr.n_ptr = xlarg(&args);
  644.     ehook.n_ptr = xlarg(&args);
  645.     ahook.n_ptr = xlarg(&args);
  646.     xllastarg(args);
  647.  
  648.     /* bind *evalhook* and *applyhook* to the hook functions */
  649.     oldenv = xlenv;
  650.     xlsbind(s_evalhook,ehook.n_ptr);
  651.     xlsbind(s_applyhook,ahook.n_ptr);
  652.  
  653.     /* evaluate the expression (bypassing *evalhook*) */
  654.     val = xlxeval(expr.n_ptr);
  655.  
  656.     /* unbind the hook variables */
  657.     xlunbind(oldenv);
  658.  
  659.     /* restore the previous stack frame */
  660.     xlstack = oldstk;
  661.  
  662.     /* return the result */
  663.     return (val);
  664. }
  665.  
  666. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  667. LOCAL dobindings(blist,pflag)
  668.   NODE *blist; int pflag;
  669. {
  670.     NODE *oldstk,list,bnd,sym,val;
  671.  
  672.     /* create a new stack frame */
  673.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  674.  
  675.    /* bind each symbol in the list of bindings */
  676.     for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  677.  
  678.     /* get the next binding */
  679.     bnd.n_ptr = car(list.n_ptr);
  680.  
  681.     /* handle a symbol */
  682.     if (symbolp(bnd.n_ptr)) {
  683.         sym.n_ptr = bnd.n_ptr;
  684.         val.n_ptr = NIL;
  685.     }
  686.  
  687.     /* handle a list of the form (symbol expr) */
  688.     else if (consp(bnd.n_ptr)) {
  689.         sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
  690.         val.n_ptr = xlevarg(&bnd.n_ptr);
  691.     }
  692.     else
  693.         xlfail("bad binding");
  694.  
  695.     /* bind the value to the symbol */
  696.     if (pflag)
  697.         xlbind(sym.n_ptr,val.n_ptr);
  698.     else
  699.         xlsbind(sym.n_ptr,val.n_ptr);
  700.     }
  701.  
  702.     /* fix the bindings on a parallel let */
  703.     if (pflag)
  704.     xlfixbindings();
  705.  
  706.     /* restore the previous stack frame */
  707.     xlstack = oldstk;
  708. }
  709.  
  710. /* doupdates - handle updates for do/do* */
  711. doupdates(blist,pflag)
  712.   NODE *blist; int pflag;
  713. {
  714.     NODE *oldstk,*oldenv,*oldnewenv,list,bnd,sym,val;
  715.  
  716.     /* create a new stack frame */
  717.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  718.  
  719.     /* initialize the local environment */
  720.     if (pflag) {
  721.     oldenv = xlenv; oldnewenv = xlnewenv;
  722.     }
  723.  
  724.     /* bind each symbol in the list of bindings */
  725.     for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  726.  
  727.     /* get the next binding */
  728.     bnd.n_ptr = car(list.n_ptr);
  729.  
  730.     /* handle a list of the form (symbol expr) */
  731.     if (consp(bnd.n_ptr)) {
  732.         sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
  733.         bnd.n_ptr = cdr(bnd.n_ptr);
  734.         if (bnd.n_ptr) {
  735.         val.n_ptr = xlevarg(&bnd.n_ptr);
  736.         if (pflag)
  737.             xlbind(sym.n_ptr,val.n_ptr);
  738.         else
  739.             sym.n_ptr->n_symvalue = val.n_ptr;
  740.         }
  741.     }
  742.     }
  743.  
  744.     /* fix the bindings on a parallel let */
  745.     if (pflag) {
  746.     xlfixbindings();
  747.     xlenv = oldenv; xlnewenv = oldnewenv;
  748.     }
  749.  
  750.     /* restore the previous stack frame */
  751.     xlstack = oldstk;
  752. }
  753.  
  754. /* tagblock - execute code within a block and tagbody */
  755. int tagblock(code,pval)
  756.   NODE *code,**pval;
  757. {
  758.     NODE *oldstk,arg;
  759.     CONTEXT cntxt;
  760.     int type,sts;
  761.  
  762.     /* create a new stack frame */
  763.     oldstk = xlsave(&arg,NULL);
  764.  
  765.     /* initialize */
  766.     arg.n_ptr = code;
  767.  
  768.     /* establish an execution context */
  769.     xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
  770.  
  771.     /* check for a 'return' */
  772.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  773.     *pval = xlvalue;
  774.     sts = TRUE;
  775.     }
  776.  
  777.     /* otherwise, enter the body */
  778.     else {
  779.  
  780.     /* check for a 'go' */
  781.     if (type == CF_GO)
  782.         arg.n_ptr = xlvalue;
  783.  
  784.     /* evaluate each expression in the body */
  785.     while (consp(arg.n_ptr))
  786.         if (consp(car(arg.n_ptr)))
  787.         xlevarg(&arg.n_ptr);
  788.         else
  789.         arg.n_ptr = cdr(arg.n_ptr);
  790.  
  791.     /* fell out the bottom of the loop */
  792.     *pval = NIL;
  793.     sts = FALSE;
  794.     }
  795.     xlend(&cntxt);
  796.  
  797.     /* restore the previous stack frame */
  798.     xlstack = oldstk;
  799.  
  800.     /* return status */
  801.     return (sts);
  802. }
  803.